home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DELPHI32
/
DEBUG
/
DTRACE32
/
DTRACE32.ZIP
/
UTrace.pas
< prev
Wrap
Pascal/Delphi Source File
|
1996-09-25
|
12KB
|
516 lines
unit UTrace;
interface
uses
Windows,Messages,Classes,Forms,SysUtils;
type
TDebugSeverity = (cNone,cInfo,cWarning,cError);
procedure Assert(Condition : Boolean;TheText : String);
procedure AssertFmt(Condition : Boolean;TheFormat : String;const Args: Array of const);
procedure DebugDump(TheText : String;Address : Pointer;Count : Integer);
procedure Debug(TheSeverity : TDebugSeverity;TheText : String);
procedure DebugFmt(TheSeverity : TDebugSeverity;TheFormat : String;const Args: Array of const);
procedure DebugInfo(TheText : String);
procedure DebugInfoFmt(TheFormat : String;const Args: Array of const);
procedure DebugWarn(TheText : String);
procedure DebugWarnFmt(TheFormat : String;const Args: Array of const);
procedure DebugErr(TheText : String);
procedure DebugErrFmt(TheFormat : String;const Args: Array of const);
implementation
{$StackFrames On}
{$DebugInfo Off}
type
Tcds = Record
dwData : Integer;
cbData : Integer;
lpData : Pointer;
end;
TDebugStruct = Record
dwSize : Integer;
dwCodeAddress : Integer;
dwLineNumber : Integer;
SystemTime : TSystemTime;
Severity : Byte;
Data : Array[0..MaxInt-50] of Char;
end;
pTDebugStruct = ^TDebugStruct;
TRange = class
Start,LineNum : Integer;
ModuleIndex : Word;
end;
TRange1 = class
Start : Integer;
ProcName : String;
end;
TRangeList = class(TList)
{ This is a list of ranges of addresses to report }
destructor destroy; override;
procedure FreeAll;
{ Frees all the ranges }
function Find(target:Integer):Integer;
{ Checks whether start <= target <= stop
for some entry in the list }
procedure ReadMapFile(filename:string);
procedure ReadMapFile1(Filename:string);
{ Reads a .MAP file to initialize }
end;
var
SaveExit : Pointer;
Range : TRange;
Range1 : TRange1;
RangeList,
RangeList1 : TRangeList;
ModuleList : TStringList;
pDebug : pTDebugStruct;
Mapshift : integer;
function ConvertAddr(Address: Pointer): Pointer; assembler;
asm
TEST EAX,EAX { Always convert nil to nil }
JE @@1
SUB EAX,OFFSET TextStart
@@1:
end;
procedure _Debug(BasePointer : pointer;TheSeverity : TDebugSeverity;TheText : String);
var
cds : Tcds;
TheWindow : THandle;
MemNeeded : Integer;
SourceAddr : Integer;
ModuleText : String;
SourceIndex,
ProcIndex : Integer;
begin
TheWindow := FindWindow('TTraceForm',Nil);
if TheWindow <> 0 then
begin
pChar(BasePointer) := pChar(BasePointer)+4;
SourceAddr := LongInt(BasePointer^);
SourceAddr := SourceAddr-5;
GetSystemTime(pDebug^.SystemTime);
SourceIndex := RangeList.Find(SourceAddr);
ProcIndex := RangeList1.Find(SourceAddr);
ModuleText := TRange1(RangeList1.Items[ProcIndex]).ProcName;
ModuleText := ModuleText + ' ' + ModuleList.Strings[TRange(RangeList.Items[SourceIndex]).ModuleIndex];
MemNeeded := Integer(pChar(@pDebug^.Data) - pChar(@pDebug^.dwSize)) + Length(ModuleText)+ 1 + Length(TheText) + 1;
pDebug^.dwSize := MemNeeded;
pDebug^.dwLineNumber := TRange(RangeList.Items[SourceIndex]).LineNum;
pDebug^.dwCodeAddress := SourceAddr-MapShift;
pDebug^.Severity := Byte(TheSeverity);
StrPCopy(pDebug^.Data,ModuleText);
StrPCopy(pChar(@pDebug^.Data[Length(ModuleText)+1]),TheText);
cds.dwData := 0;
cds.cbData := MemNeeded;
cds.lpData := pDebug;
if Assigned(Application.MainForm) then
SendMessage(TheWindow,WM_COPYDATA,Application.MainForm.Handle,Longint(@cds))
else
SendMessage(TheWindow,WM_COPYDATA,0,Longint(@cds));
end;
end;
procedure Assert(Condition : Boolean;TheText : String);
var
BasePointer : ^LongInt;
begin
asm
mov BasePointer,ebp
end;
if not Condition then
begin
_Debug(BasePointer,cError,TheText);
end;
halt;
end;
procedure AssertFmt(Condition : Boolean;TheFormat : String;const Args: Array of const);
var
BasePointer : ^LongInt;
TheText : String;
begin
asm
mov BasePointer,ebp
end;
if not Condition then
begin
FmtStr(TheText,TheFormat,Args);
_Debug(BasePointer,cError,TheText);
end;
halt;
end;
procedure DebugDump(TheText : String;Address : Pointer;Count : Integer);
var
BasePointer : ^LongInt;
TheText1 : String;
i : Integer;
begin
asm
mov BasePointer,ebp
end;
FmtStr(TheText1,'%.8x:',[LongInt(Address)]);
TheText := TheText + #13 + TheText1;
for i := 0 to Count-1 do
begin
FmtStr(TheText1,'%.2x ',[Byte((pChar(Address)+i)^)]);
TheText := TheText + TheText1;
if (LongInt(Address)+i) mod 16 = 15 then
begin
FmtStr(TheText1,'%.8x:',[LongInt(Address)+i+1]);
TheText := TheText + #13 + TheText1;
end;
end;
_Debug(BasePointer,cInfo,TheText);
end;
procedure DebugInfo(TheText : String);
var
BasePointer : ^LongInt;
begin
asm
mov BasePointer,ebp
end;
_Debug(BasePointer,cInfo,TheText);
end;
procedure DebugInfoFmt(TheFormat : String;const Args: Array of const);
var
BasePointer : ^LongInt;
TheText : String;
begin
asm
mov BasePointer,ebp
end;
FmtStr(TheText,TheFormat,Args);
_Debug(BasePointer,cInfo,TheText);
end;
procedure DebugWarn(TheText : String);
var
BasePointer : ^LongInt;
begin
asm
mov BasePointer,ebp
end;
_Debug(BasePointer,cWarning,TheText);
end;
procedure DebugWarnFmt(TheFormat : String;const Args: Array of const);
var
BasePointer : ^LongInt;
TheText : String;
begin
asm
mov BasePointer,ebp
end;
FmtStr(TheText,TheFormat,Args);
_Debug(BasePointer,cWarning,TheText);
end;
procedure DebugErr(TheText : String);
var
BasePointer : ^LongInt;
begin
asm
mov BasePointer,ebp
end;
_Debug(BasePointer,cError,TheText);
end;
procedure DebugErrFmt(TheFormat : String;const Args: Array of const);
var
BasePointer : ^LongInt;
TheText : String;
begin
asm
mov BasePointer,ebp
end;
FmtStr(TheText,TheFormat,Args);
_Debug(BasePointer,cError,TheText);
end;
procedure DebugFmt(TheSeverity : TDebugSeverity;TheFormat : String;const Args: Array of const);
var
BasePointer : ^LongInt;
TheText : String;
begin
asm
mov BasePointer,ebp
end;
FmtStr(TheText,TheFormat,Args);
_Debug(BasePointer,TheSeverity,TheText);
end;
procedure Debug(TheSeverity : TDebugSeverity;TheText : String);
var
BasePointer : ^LongInt;
begin
asm
mov BasePointer,ebp
end;
_Debug(BasePointer,TheSeverity,TheText);
end;
procedure TRangeList.FreeAll;
var
i : integer;
begin
for i := 0 to pred(Count) do
TRange(Items[i]).Free;
Count := 0;
end;
destructor TRangeList.Destroy;
begin
FreeAll;
inherited Destroy;
end;
function TRangeList.Find(Target:Integer):Integer;
var
ThePos : Integer;
procedure Seek(MinPos,MaxPos : Integer);
var
iMinPos,iMaxPos : Integer;
begin
if MaxPos-MinPos = 0 then
ThePos := MaxPos
else
begin
if MaxPos-MinPos = 1 then
begin
if TRange(Items[MaxPos]).Start > Target then
begin
iMinPos := MinPos;
iMaxPos := MinPos;
end
else
begin
iMinPos := MaxPos;
iMaxPos := MaxPos;
end;
end
else
begin
ThePos := MinPos + (MaxPos-MinPos) div 2;
if TRange(Items[ThePos]).Start = Target then
begin
iMinPos := ThePos;
iMaxPos := ThePos;
end
else if TRange(Items[ThePos]).Start < Target then
begin
iMinPos := ThePos;
iMaxPos := MaxPos;
end
else if TRange(Items[ThePos]).Start > Target then
begin
iMinPos := MinPos;
iMaxPos := ThePos;
end;
end;
if iMinPos <> iMaxPos then
Seek(IMinPos,IMaxPos)
else
ThePos := iMinPos;
end;
end;
begin
Seek(0,Count-1);
Result := ThePos
end;
procedure TRangeList.ReadMapFile(Filename:string);
var
Map : textfile;
Line : string;
Buffer : array[1..8192] of byte;
StartModuleName,
EndModuleName,
ModuleIndex : Integer;
a : Pointer;
begin
a := ConvertAddr(@Self);
Mapshift := Integer(pChar(@Self)-pChar(a));
MapShift := MapShift - 512;
ModuleIndex := 0;
AssignFile(Map,Filename);
SetTextBuf(Map,Buffer);
{$i-}
Reset(Map);
{$i+}
if IoResult = 0 then
begin
while not Eof(Map) do
begin
Readln(Map,Line);
if Pos('Publics by Value',Line) > 0 then
break;
end;
while not Eof(Map) do
begin
Readln(Map,Line);
if Pos('TextStart',Line) > 0 then
begin
Mapshift := Integer(@TextStart) - StrToInt('$'+Copy(line,7,8));
break;
end;
end;
while not Eof(Map) do
begin
readln(Map,Line);
if pos('Line numbers for ',Line) > 0 then
begin
StartModuleName := Pos('(',Line);
StartModuleName := StartModuleName+1;
EndModuleName := Pos(')',Line);
ModuleList.Add(ExtractFileName(Copy(Line,StartModuleName,EndModuleName-StartModuleName)));
ModuleIndex := ModuleList.Count -1;
break;
end;
end;
while not eof(Map) do
begin
readln(Map,Line);
if pos('Program entry point',Line) <> 0 then
break;
if pos('Line numbers for ',Line) > 0 then
begin
StartModuleName := Pos('(',Line);
StartModuleName := StartModuleName+1;
EndModuleName := Pos(')',Line);
ModuleList.Add(ExtractFileName(Copy(Line,StartModuleName,EndModuleName-StartModuleName)));
ModuleIndex := ModuleList.Count -1;
end
else
begin
if Length(Line) > 19 then
begin
Range := TRange.Create;
Range.Start := Mapshift + StrToInt('$'+Copy(Line,13,8));
Range.LineNum := StrToInt(Copy(Line,1,6));
Range.ModuleIndex := ModuleIndex;
Add(Range);
end;
if Length(Line) > 39 then
begin
Range := TRange.Create;
Range.Start := Mapshift + StrToInt('$'+Copy(Line,33,8));
Range.LineNum := StrToInt(Copy(Line,21,6));
Range.ModuleIndex := ModuleIndex;
Add(Range);
end;
if Length(Line) > 59 then
begin
Range := TRange.Create;
Range.Start := Mapshift + StrToInt('$'+Copy(Line,53,8));
Range.LineNum := StrToInt(Copy(Line,41,6));
Range.ModuleIndex := ModuleIndex;
Add(Range);
end;
if Length(Line) > 79 then
begin
Range := TRange.Create;
Range.Start := Mapshift + StrToInt('$'+Copy(Line,73,8));
Range.LineNum := StrToInt(Copy(Line,61,6));
Range.ModuleIndex := ModuleIndex;
Add(Range);
end;
if Capacity - Count < 10 then
Capacity := Capacity + 50;
end;
end;
Closefile(Map);
end;
end;
procedure TRangeList.ReadMapFile1(Filename:string);
var
Map : textfile;
Line : string;
Buffer : array[1..8192] of byte;
begin
AssignFile(Map,Filename);
SetTextBuf(Map,Buffer);
{$i-}
Reset(Map);
{$i+}
if IoResult = 0 then
begin
while not Eof(Map) do
begin
Readln(Map,Line);
if Pos('Publics by Value',Line) > 0 then
break;
end;
while not eof(Map) do
begin
readln(Map,Line);
if pos('Line numbers for',Line) <> 0 then
break;
if pos('0001:',Line) <> 0 then
begin
Range1 := TRange1.Create;
Range1.Start := Mapshift + StrToInt('$'+Copy(Line,7,8));
Range1.ProcName := Copy(Line,22,99);
Add(Range1);
end;
if Capacity - Count < 10 then
Capacity := Capacity + 50;
end;
Closefile(Map);
end;
end;
procedure MyExit;
begin
ExitProc := SaveExit;
if Assigned(pDebug) then
FreeMem(pDebug);
if Assigned(RangeList) then
begin
RangeList.Destroy;
end;
if Assigned(RangeList1) then
begin
RangeList1.Destroy;
end;
if Assigned(ModuleList) then
begin
ModuleList.Destroy;
end;
end;
begin
ModuleList := TStringList.Create;
ModuleList.Add(ExtractFileName(Application.ExeName));
RangeList := TRangeList.Create;
RangeList1 := TRangeList.Create;
Range := TRange.Create;
Range.Start := 0;
Range.LineNum := 0;
Range.ModuleIndex := 0;
RangeList.Add(Range);
Range1 := TRange1.Create;
Range1.Start := 0;
Range1.ProcName := '';
RangeList1.Add(Range1);
RangeList.ReadMapFile(ChangeFileExt(Application.ExeName,'.map'));
RangeList1.ReadMapFile1(ChangeFileExt(Application.ExeName,'.map'));
GetMem(pDebug,2000);
SaveExit := ExitProc;
ExitProc := @MyExit;
end.